home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Visual Basic 4 Database How-To
/
Visual Basic 4 Database - How-to (The Waite Group)(1995).iso
/
permit32.fr_
/
permit32.fr
Wrap
Text File
|
1995-09-04
|
17KB
|
515 lines
VERSION 4.00
Begin VB.Form Form1
BackColor = &H00C0C0C0&
Caption = "Permitter"
ClientHeight = 4350
ClientLeft = 690
ClientTop = 1875
ClientWidth = 6750
BeginProperty Font
name = "MS Sans Serif"
charset = 0
weight = 700
size = 8.25
underline = 0 'False
italic = 0 'False
strikethrough = 0 'False
EndProperty
Height = 4755
Left = 630
LinkTopic = "Form1"
ScaleHeight = 4350
ScaleWidth = 6750
Top = 1530
Width = 6870
Begin VB.CommandButton cmdClose
Caption = "&Close"
Height = 495
Left = 3780
TabIndex = 12
Top = 3540
Width = 1755
End
Begin VB.CommandButton cmdSave
Caption = "S&ave Permissions"
Height = 555
Left = 1260
TabIndex = 11
Top = 3540
Width = 1755
End
Begin VB.CheckBox chkPermission
BackColor = &H00C0C0C0&
Caption = "&Delete Data"
Enabled = 0 'False
Height = 255
Index = 6
Left = 3720
TabIndex = 10
Top = 2940
Width = 1875
End
Begin VB.CheckBox chkPermission
BackColor = &H00C0C0C0&
Caption = "&Insert Data"
Enabled = 0 'False
Height = 255
Index = 5
Left = 3720
TabIndex = 9
Top = 2640
Width = 1875
End
Begin VB.CheckBox chkPermission
BackColor = &H00C0C0C0&
Caption = "Upda&te Data"
Enabled = 0 'False
Height = 255
Index = 4
Left = 3720
TabIndex = 8
Top = 2340
Width = 1875
End
Begin VB.CheckBox chkPermission
BackColor = &H00C0C0C0&
Caption = "R&ead Data"
Enabled = 0 'False
Height = 255
Index = 3
Left = 3720
TabIndex = 7
Top = 2040
Width = 1875
End
Begin VB.CheckBox chkPermission
BackColor = &H00C0C0C0&
Caption = "Admini&ster"
Enabled = 0 'False
Height = 255
Index = 2
Left = 960
TabIndex = 6
Top = 2940
Width = 1875
End
Begin VB.CheckBox chkPermission
BackColor = &H00C0C0C0&
Caption = "&Modify Design"
Enabled = 0 'False
Height = 255
Index = 1
Left = 960
TabIndex = 5
Top = 2640
Width = 1875
End
Begin VB.CheckBox chkPermission
BackColor = &H00C0C0C0&
Caption = "&Read Design"
Enabled = 0 'False
Height = 255
Index = 0
Left = 960
TabIndex = 4
Top = 2340
Width = 1875
End
Begin VB.ListBox lstTables
Height = 1230
Left = 3660
TabIndex = 1
Top = 360
Width = 2535
End
Begin VB.ListBox lstUsers
Height = 1230
Left = 360
Sorted = -1 'True
TabIndex = 0
Top = 360
Width = 2535
End
Begin VB.Label lblPermissions
BackColor = &H00C0C0C0&
Height = 255
Left = 1620
TabIndex = 14
Top = 1920
Width = 1215
End
Begin VB.Label Label3
AutoSize = -1 'True
BackColor = &H00C0C0C0&
Caption = "Permissions:"
Height = 195
Left = 360
TabIndex = 13
Top = 1920
Width = 1065
End
Begin VB.Label Label2
AutoSize = -1 'True
BackColor = &H00C0C0C0&
Caption = "Tables and queries:"
Height = 195
Left = 3660
TabIndex = 3
Top = 120
Width = 1695
End
Begin VB.Label Label1
AutoSize = -1 'True
BackColor = &H00C0C0C0&
Caption = "Users:"
Height = 195
Left = 360
TabIndex = 2
Top = 120
Width = 555
End
End
Attribute VB_Name = "Form1"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Const P_READDESIGN = 0
Const P_MODIFYDESIGN = 1
Const P_ADMINISTER = 2
Const P_READDATA = 3
Const P_UPDATEDATA = 4
Const P_INSERTDATA = 5
Const P_DELETEDATA = 6
Const DBSEC_READDESIGN = 4
Const DBSEC_MODIFYDESIGN = 65756
Const DBSEC_ADMINISTER = 852478
Const DBSEC_READDATA = 20
Const DBSEC_UPDATEDATA = 84
Const DBSEC_INSERTDATA = 52
Const DBSEC_DELETEDATA = 148
Const DBSEC_MODIFYDESIGN_INSERTDATA = 65788
Const DBSEC_UPDATEINSERTDATA = 116
Const DBSEC_UPDATEDELETEDATA = 212
Const DBSEC_INSERTDELETEDATA = 180
Const DBSEC_UPDATEINSERTDELETEDATA = 244
Const DBSEC_NOPERMISSIONS = 0
Const DBSEC_READSEC = 131072
Const CHK_CHECKED = 1
Const CHK_UNCHECKED = 0
Private db As Database
#If Win32 Then
Private Declare Function GetWindowsDirectory Lib "Kernel32" _
Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, _
ByVal nSize As Long) As Long
#Else
Private Declare Function GetWindowsDirectory Lib "Kernel" _
(ByVal lpBuffer As String, _
ByVal nSize As Integer) As Integer
#End If
Private Sub Form_Load()
Dim myUser As String, myPass As String
Dim i As Integer
Dim winDir As String * 128
Dim dirLen As Integer
Dim dbName As String
On Error GoTo LoadError
' Set the user and passwords for initial login.
myUser = "Admin"
myPass = "theboss"
' read VBDBHT.INI to get the name of the system database,
' then assign that name to the SystemDB property
DBEngine.SystemDB = GetSystemDatabase()
' log in
DBEngine.DefaultUser = myUser
DBEngine.DefaultPassword = myPass
' Get the database name and open the database.
dbName = DataPath() & "\CHAPTER.09\ORDERS.MDB" ' DataPath() is in READINI.BAS
Set db = DBEngine.Workspaces(0).OpenDatabase(dbName)
' Fill the list boxes.
FillUserList
FillTableList
Exit Sub
LoadError:
MsgBox Err.Description, vbCritical
End
End Sub
Sub FillUserList()
Dim usr As User
For Each usr In DBEngine.Workspaces(0).Users
If UCase$(usr.Name) <> "CREATOR" And UCase$(usr.Name) <> "ENGINE" And UCase$(usr.Name) <> "ADMIN" Then
lstUsers.AddItem usr.Name
End If
Next
End Sub
Sub FillTableList()
Dim doc As Document
For Each doc In db.Containers("Tables").Documents
If Left$(doc.Name, 4) <> "MSys" Then lstTables.AddItem doc.Name
Next
End Sub
Private Sub lstUsers_Click()
Dim i As Integer
If lstTables.ListIndex > -1 Then
If ReadPermissions() = False Then
lstUsers.ListIndex = -1
For i = 0 To 6
chkPermission(i).Value = CHK_UNCHECKED
chkPermission(i).Enabled = False
Next i
End If
End If
End Sub
Private Sub lstTables_Click()
Dim i As Integer
If lstUsers.ListIndex > -1 Then
If ReadPermissions() = False Then
lstTables.ListIndex = -1
For i = 0 To 6
chkPermission(i).Value = CHK_UNCHECKED
chkPermission(i).Enabled = False
Next i
End If
End If
End Sub
Function ReadPermissions() As Boolean
Dim pass As String
Dim i As Integer
Dim permissionCode As Long
Dim doc As Document
On Error GoTo ReadPermissionsError
Set doc = db.Containers("Tables").Documents(lstTables.Text)
doc.UserName = lstUsers.Text
For i = 0 To 6
chkPermission(i).Enabled = True
chkPermission(i).Value = CHK_UNCHECKED
Next i
lblPermissions.Caption = doc.Permissions
permissionCode = doc.Permissions
Select Case permissionCode
Case DBSEC_ADMINISTER
For i = 0 To 6
chkPermission(i).Value = CHK_CHECKED
Next i
Case DBSEC_MODIFYDESIGN
chkPermission(P_MODIFYDESIGN).Value = CHK_CHECKED
chkPermission(P_READDESIGN).Value = CHK_CHECKED
chkPermission(P_READDATA).Value = CHK_CHECKED
chkPermission(P_UPDATEDATA).Value = CHK_CHECKED
chkPermission(P_DELETEDATA).Value = CHK_CHECKED
Case DBSEC_UPDATEDATA
chkPermission(P_UPDATEDATA).Value = CHK_CHECKED
chkPermission(P_READDESIGN).Value = CHK_CHECKED
chkPermission(P_READDATA).Value = CHK_CHECKED
Case DBSEC_DELETEDATA
chkPermission(P_DELETEDATA).Value = CHK_CHECKED
chkPermission(P_READDESIGN).Value = CHK_CHECKED
chkPermission(P_READDATA).Value = CHK_CHECKED
Case DBSEC_INSERTDATA
chkPermission(P_INSERTDATA).Value = CHK_CHECKED
chkPermission(P_READDESIGN).Value = CHK_CHECKED
chkPermission(P_READDATA).Value = CHK_CHECKED
Case DBSEC_READDATA
chkPermission(P_READDATA).Value = CHK_CHECKED
chkPermission(P_READDESIGN).Value = CHK_CHECKED
Case DBSEC_READDESIGN
chkPermission(P_READDESIGN).Value = CHK_CHECKED
Case DBSEC_MODIFYDESIGN_INSERTDATA
chkPermission(P_MODIFYDESIGN).Value = CHK_CHECKED
chkPermission(P_READDESIGN).Value = CHK_CHECKED
chkPermission(P_READDATA).Value = CHK_CHECKED
chkPermission(P_UPDATEDATA).Value = CHK_CHECKED
chkPermission(P_INSERTDATA).Value = CHK_CHECKED
chkPermission(P_DELETEDATA).Value = CHK_CHECKED
Case DBSEC_UPDATEINSERTDATA
chkPermission(P_UPDATEDATA).Value = CHK_CHECKED
chkPermission(P_INSERTDATA).Value = CHK_CHECKED
chkPermission(P_READDESIGN).Value = CHK_CHECKED
chkPermission(P_READDATA).Value = CHK_CHECKED
Case DBSEC_UPDATEDELETEDATA
chkPermission(P_UPDATEDATA).Value = CHK_CHECKED
chkPermission(P_READDESIGN).Value = CHK_CHECKED
chkPermission(P_READDATA).Value = CHK_CHECKED
chkPermission(P_DELETEDATA).Value = CHK_CHECKED
Case DBSEC_INSERTDELETEDATA
chkPermission(P_DELETEDATA).Value = CHK_CHECKED
chkPermission(P_READDESIGN).Value = CHK_CHECKED
chkPermission(P_READDATA).Value = CHK_CHECKED
chkPermission(P_INSERTDATA).Value = CHK_CHECKED
Case DBSEC_UPDATEINSERTDELETEDATA
chkPermission(P_UPDATEDATA).Value = CHK_CHECKED
chkPermission(P_READDESIGN).Value = CHK_CHECKED
chkPermission(P_READDATA).Value = CHK_CHECKED
chkPermission(P_DELETEDATA).Value = CHK_CHECKED
chkPermission(P_INSERTDATA).Value = CHK_CHECKED
End Select
ReadPermissions = True
Exit Function
ReadPermissionsError:
MsgBox Err.Description & " (" & Err.Number & ")", vbExclamation
ReadPermissions = False
Exit Function
End Function
Private Sub chkPermission_Click(Index As Integer)
Dim i As Integer
Select Case Index
Case P_ADMINISTER
If chkPermission(Index).Value = CHK_CHECKED Then
For i = 0 To 6
chkPermission(i).Value = CHK_CHECKED
Next i
End If
Case P_READDESIGN
If chkPermission(Index).Value = CHK_UNCHECKED Then
For i = 0 To 6
chkPermission(i).Value = CHK_UNCHECKED
Next i
End If
Case P_READDATA
If chkPermission(Index).Value = CHK_CHECKED Then
chkPermission(P_READDESIGN).Value = CHK_CHECKED
Else
chkPermission(P_MODIFYDESIGN).Value = CHK_UNCHECKED
chkPermission(P_UPDATEDATA).Value = CHK_UNCHECKED
chkPermission(P_DELETEDATA).Value = CHK_UNCHECKED
chkPermission(P_INSERTDATA).Value = CHK_UNCHECKED
chkPermission(P_ADMINISTER).Value = CHK_UNCHECKED
End If
Case P_MODIFYDESIGN
If chkPermission(Index).Value = CHK_CHECKED Then
chkPermission(P_READDESIGN).Value = CHK_CHECKED
chkPermission(P_READDATA).Value = CHK_CHECKED
chkPermission(P_UPDATEDATA).Value = CHK_CHECKED
chkPermission(P_INSERTDATA).Value = CHK_CHECKED
Else
chkPermission(P_ADMINISTER).Value = CHK_UNCHECKED
End If
Case P_UPDATEDATA
If chkPermission(Index).Value = CHK_CHECKED Then
chkPermission(P_READDESIGN).Value = CHK_CHECKED
chkPermission(P_READDATA).Value = CHK_CHECKED
Else
chkPermission(P_ADMINISTER).Value = CHK_UNCHECKED
chkPermission(P_MODIFYDESIGN).Value = CHK_UNCHECKED
End If
Case P_DELETEDATA
If chkPermission(Index).Value = CHK_CHECKED Then
chkPermission(P_READDESIGN).Value = CHK_CHECKED
chkPermission(P_READDATA).Value = CHK_CHECKED
Else
chkPermission(P_ADMINISTER).Value = CHK_UNCHECKED
chkPermission(P_MODIFYDESIGN).Value = CHK_UNCHECKED
End If
Case P_INSERTDATA
If chkPermission(Index).Value = CHK_CHECKED Then
chkPermission(P_READDESIGN).Value = CHK_CHECKED
chkPermission(P_READDATA).Value = CHK_CHECKED
Else
chkPermission(P_ADMINISTER).Value = CHK_UNCHECKED
End If
End Select
End Sub
Private Sub cmdSave_Click()
Dim doc As Document
Dim permissionCode As Long
On Error GoTo SaveError
Set doc = db.Containers("Tables").Documents(lstTables.Text)
doc.UserName = lstUsers.Text
If chkPermission(P_ADMINISTER) = CHK_CHECKED Then
permissionCode = DBSEC_ADMINISTER
ElseIf chkPermission(P_MODIFYDESIGN) = CHK_CHECKED Then
If chkPermission(P_INSERTDATA) = CHK_CHECKED Then
permissionCode = DBSEC_MODIFYDESIGN_INSERTDATA
Else
permissionCode = DBSEC_MODIFYDESIGN
End If
ElseIf chkPermission(P_UPDATEDATA) = CHK_CHECKED Then
If chkPermission(P_INSERTDATA) = CHK_CHECKED Then
If chkPermission(P_DELETEDATA) = CHK_CHECKED Then
permissionCode = DBSEC_UPDATEINSERTDELETEDATA
Else
permissionCode = DBSEC_UPDATEINSERTDATA
End If
Else
permissionCode = DBSEC_UPDATEDATA
End If
ElseIf chkPermission(P_INSERTDATA) = CHK_CHECKED Then
If chkPermission(P_DELETEDATA) = CHK_CHECKED Then
permissionCode = DBSEC_INSERTDELETEDATA
Else
permissionCode = DBSEC_INSERTDATA
End If
ElseIf chkPermission(P_DELETEDATA) = CHK_CHECKED Then
permissionCode = DBSEC_DELETEDATA
ElseIf chkPermission(P_READDATA) = CHK_CHECKED Then
permissionCode = DBSEC_READDATA
ElseIf chkPermission(P_READDESIGN) = CHK_CHECKED Then
permissionCode = DBSEC_READDESIGN
Else
permissionCode = DBSEC_NOPERMISSIONS
End If
If UCase$(doc.UserName) = "ADMIN" Then permissionCode = permissionCode + DBSEC_READSEC
doc.Permissions = permissionCode
lblPermissions.Caption = doc.Permissions
Exit Sub
SaveError:
MsgBox Err.Description & " (" & Err.Number & ")"
Exit Sub
End Sub
Private Sub cmdClose_Click()
End
End Sub
Private Function GetSystemDatabase() As String
' Returns the name of the system directory
Const INI_FILENAME = "VBDBHT.INI"
Const MAX_PATH = 128
Dim lpReturnedString As String * MAX_PATH
Dim bytesBack As Integer
bytesBack = GetPrivateProfileString("Options", _
"SystemDB", "", lpReturnedString, MAX_PATH, INI_FILENAME)
GetSystemDatabase = IIf(bytesBack > 0, Left$(lpReturnedString, bytesBack), "")
End Function